home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / PPBAND.C < prev    next >
C/C++ Source or Header  |  1992-02-11  |  13KB  |  554 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/src/microcode/RCS/Ppband.c,v 9.43 1992/02/11 21:15:00 mhwu Exp $
  4.  
  5. Copyright (c) 1987-1992 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Dumps Scheme FASL in user-readable form. */
  36.  
  37. #include <stdio.h>
  38. #include <ctype.h>
  39. #include "ansidecl.h"
  40. #include "config.h"
  41. #include "errors.h"
  42. #include "types.h"
  43. #include "const.h"
  44. #include "object.h"
  45. #include "gccode.h"
  46. #include "sdata.h"
  47.  
  48. #define fast register
  49.  
  50. /* These are needed when there is no compiler support. */
  51.  
  52. extern void EXFUN (gc_death,
  53.            (long code, char *, SCHEME_OBJECT *, SCHEME_OBJECT *));
  54.  
  55. extern char
  56.   gc_death_message_buffer[];
  57.  
  58. void
  59. DEFUN (gc_death, (code, message, scan, free),
  60.        long code AND char * message
  61.        AND SCHEME_OBJECT * scan AND SCHEME_OBJECT * free)
  62. {
  63.   fprintf (stderr, "gc_death: %s.\n", message);
  64.   exit (1);
  65. }
  66.  
  67. /* These are needed by load.c */
  68.  
  69. static SCHEME_OBJECT * memory_base;
  70.  
  71. #ifdef OS2
  72.  
  73. #include <fcntl.h>
  74. #include <io.h>
  75. #include <sys\types.h>
  76.  
  77. #define fread OS2_fread
  78. extern off_t EXFUN (OS2_fread, (char *, unsigned int, off_t, FILE *));
  79.  
  80. #define fwrite OS2_fwrite
  81. extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *));
  82.  
  83. #endif /* OS2 */
  84.  
  85. long
  86. DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
  87. {
  88. #ifdef OS2
  89.   setmode ((fileno (stdin)), O_BINARY);
  90. #endif /* OS2 */
  91.  
  92.   return (fread (((char *) To_Where),
  93.          (sizeof (SCHEME_OBJECT)),
  94.          Count,
  95.          stdin));
  96. }
  97.  
  98. #define INHIBIT_COMPILED_VERSION_CHECK
  99. #define INHIBIT_CHECKSUMS
  100. #include "load.c"
  101.  
  102. #ifdef HEAP_IN_LOW_MEMORY
  103. #ifdef hp9000s800
  104. #  define File_To_Pointer(P)                        \
  105.     ((((long) (P)) & DATUM_MASK) / (sizeof (SCHEME_OBJECT)))
  106. #else
  107. #  define File_To_Pointer(P) ((P) / (sizeof (SCHEME_OBJECT)))
  108. #endif /* hp9000s800 */
  109. #else
  110. #  define File_To_Pointer(P) (P)
  111. #endif
  112.  
  113. #ifndef Conditional_Bug
  114. #  define Relocate(P)                            \
  115.     (((long) (P) < Const_Base) ?                    \
  116.      (File_To_Pointer (((long) (P)) - Heap_Base)) :            \
  117.      (Heap_Count + (File_To_Pointer (((long) (P)) - Const_Base))))
  118. #else
  119. #  define Relocate_Into(What, P)                    \
  120. if (((long) (P)) < Const_Base)                        \
  121.   (What) = (File_To_Pointer (((long) (P)) - Heap_Base));        \
  122. else                                    \
  123.   (What) = Heap_Count + (File_To_Pointer (((long) P) - Const_Base));
  124.  
  125. static long Relocate_Temp;
  126. #  define Relocate(P)    (Relocate_Into (Relocate_Temp, P), Relocate_Temp)
  127. #endif
  128.  
  129. static SCHEME_OBJECT *Data, *end_of_memory;
  130.  
  131. void
  132. DEFUN (print_long_as_string, (string), char *string)
  133. {
  134.   int i;
  135.   char *temp;
  136.   unsigned char c;
  137.  
  138.   temp = string;
  139.   putchar ('"');
  140.   for (i = 0; i < (sizeof (long)); i++)
  141.   {
  142.     c = *temp++;
  143.     if (isgraph ((int) c))
  144.     {
  145.       putchar (c);
  146.     }
  147.     else
  148.     {
  149.       putchar (' ');
  150.     }
  151.   }
  152.   printf ("\" = ");
  153.  
  154.   temp = string;
  155.   for (i = 0; i < (sizeof (long)); i++)
  156.   {
  157.     c = *temp++;
  158.     if (isgraph ((int) c))
  159.     {
  160.       printf ("    ");
  161.       putchar (c);
  162.     }
  163.     else
  164.     {
  165.       switch (c)
  166.       {
  167.     case '\0':
  168.       printf ("   \\0");
  169.       break;
  170.  
  171.     case ' ':
  172.       printf ("     ");
  173.       break;
  174.  
  175. #ifdef __STDC__
  176.     case '\a':
  177. #else
  178.     case '\007':
  179. #endif
  180.       printf ("   \\a");
  181.       break;
  182.  
  183.     case '\b':
  184.       printf ("   \\b");
  185.       break;
  186.  
  187.     case '\f':
  188.       printf ("   \\f");
  189.       break;
  190.  
  191.     case '\n':
  192.       printf ("   \\n");
  193.       break;
  194.  
  195.     case '\r':
  196.       printf ("   \\r");
  197.       break;
  198.  
  199.     case '\t':
  200.       printf ("   \\t");
  201.       break;
  202.  
  203.     case '\v':
  204.       printf ("   \\v");
  205.       break;
  206.  
  207.     default:
  208.       printf (" \\%03o", c);
  209.       break;
  210.       }
  211.     }
  212.   }
  213.   return;
  214. }
  215.  
  216. Boolean
  217. DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted)
  218. {
  219.   fast long i, Count;
  220.   fast char *Chars;
  221.  
  222.   Chars = ((char *) &Data[From +  STRING_CHARS]);
  223.   if ((Chars < ((char *) end_of_memory))
  224.       && (Chars >= ((char *) Data)))
  225.   {
  226.     Count = ((long) (Data[From + STRING_LENGTH_INDEX]));
  227.     if (&Chars[Count] < ((char *) end_of_memory))
  228.     {
  229.       if (Quoted)
  230.       {
  231.     putchar ('\"');
  232.       }
  233.       for (i = 0; i < Count; i++)
  234.       {
  235.     printf ("%c", *Chars++);
  236.       }
  237.       if (Quoted)
  238.       {
  239.     putchar ('\"');
  240.       }
  241.       putchar ('\n');
  242.       return (true);
  243.     }
  244.   }
  245.   if (Quoted)
  246.   {
  247.     printf ("String not in memory; datum = %lx\n", From);
  248.   }
  249.   return (false);
  250. }
  251.  
  252. #define via(File_Address) Relocate (OBJECT_DATUM (Data[File_Address]))
  253.  
  254. void
  255. DEFUN (scheme_symbol, (From), long From)
  256. {
  257.   SCHEME_OBJECT *symbol;
  258.  
  259.   symbol = &Data[From+SYMBOL_NAME];
  260.   if ((symbol >= end_of_memory) ||
  261.       (!(scheme_string (via (From + SYMBOL_NAME), false))))
  262.   {
  263.     printf ("symbol not in memory; datum = %lx\n", From);
  264.   }
  265.   return;
  266. }
  267.  
  268. static char string_buffer[10];
  269.  
  270. #define PRINT_OBJECT(type, datum)                    \
  271. {                                    \
  272.   printf ("[%s %lx]", type, datum);                    \
  273. }
  274.  
  275. #define NON_POINTER(string)                        \
  276. {                                    \
  277.   the_string = string;                            \
  278.   Points_To = The_Datum;                        \
  279.   break;                                \
  280. }
  281.  
  282. #define POINTER(string)                            \
  283. {                                    \
  284.   the_string = string;                            \
  285.   break;                                \
  286. }
  287.  
  288. char *Type_Names[] = TYPE_NAME_TABLE;
  289.  
  290. void
  291. DEFUN (Display, (Location, Type, The_Datum),
  292.                  long Location AND
  293.                  long Type AND
  294.                  long The_Datum)
  295. {
  296.   char string_buf[100];
  297.   char *the_string;
  298.   long Points_To;
  299.  
  300.   printf ("%5lx: %2lx|%6lx     ", Location, Type, The_Datum);
  301.   Points_To = Relocate ((SCHEME_OBJECT *) The_Datum);
  302.  
  303.   switch (Type)
  304.   { /* "Strange" cases */
  305.     case TC_NULL:
  306.       if (The_Datum == 0)
  307.       {
  308.     printf ("#F\n");
  309.     return;
  310.       }
  311.       NON_POINTER ("NULL");
  312.  
  313.     case TC_TRUE:
  314.       if (The_Datum == 0)
  315.       {
  316.     printf ("#T\n");
  317.     return;
  318.       }
  319.       /* fall through */
  320.  
  321.  
  322.     case TC_CHARACTER:
  323.     case TC_RETURN_CODE:
  324.     case TC_PRIMITIVE:
  325.     case TC_THE_ENVIRONMENT:
  326.     case TC_PCOMB0:
  327.     case TC_MANIFEST_SPECIAL_NM_VECTOR:
  328.     case TC_MANIFEST_NM_VECTOR:
  329.       NON_POINTER (Type_Names[Type]);
  330.  
  331.     case TC_INTERNED_SYMBOL:
  332.       PRINT_OBJECT ("INTERNED-SYMBOL", Points_To);
  333.       printf (" = ");
  334.       scheme_symbol (Points_To);
  335.       return;
  336.  
  337.     case TC_UNINTERNED_SYMBOL:
  338.       PRINT_OBJECT ("UNINTERNED-SYMBOL", Points_To);
  339.       printf (" = ");
  340.       scheme_symbol (Points_To);
  341.       return;
  342.  
  343.     case TC_CHARACTER_STRING:
  344.       PRINT_OBJECT ("CHARACTER-STRING", Points_To);
  345.       printf (" = ");
  346.       scheme_string (Points_To, true);
  347.       return;
  348.  
  349.     case TC_FIXNUM:
  350.       PRINT_OBJECT ("FIXNUM", The_Datum);
  351.       Points_To = (FIXNUM_TO_LONG ((MAKE_OBJECT (Type, The_Datum))));
  352.       printf (" = %ld\n", Points_To);
  353.       return;
  354.  
  355.     case TC_REFERENCE_TRAP:
  356.       if (The_Datum <= TRAP_MAX_IMMEDIATE)
  357.       {
  358.     NON_POINTER ("REFERENCE-TRAP");
  359.       }
  360.       else
  361.       {
  362.     POINTER ("REFERENCE-TRAP");
  363.       }
  364.  
  365.     case TC_BROKEN_HEART:
  366.       if (The_Datum == 0)
  367.       {
  368.     Points_To = 0;
  369.       }
  370.     default:
  371.       if (Type <= LAST_TYPE_CODE)
  372.       {
  373.     POINTER (Type_Names[Type]);
  374.       }
  375.       else
  376.       {
  377.     sprintf (&string_buf[0], "0x%02lx ", Type);
  378.     POINTER (&string_buf[0]);
  379.       }
  380.   }
  381.   PRINT_OBJECT (the_string, Points_To);
  382.   putchar ('\n');
  383.   return;
  384. }
  385.  
  386. SCHEME_OBJECT *
  387. DEFUN (show_area, (area, start, end, name),
  388.        fast SCHEME_OBJECT *area AND
  389.        long start AND
  390.        fast long end AND
  391.        char *name)
  392. {
  393.   fast long i;
  394.  
  395.   printf ("\n%s contents:\n\n", name);
  396.   for (i = start; i < end;  area++, i++)
  397.   {
  398.     if (((OBJECT_TYPE (*area)) == TC_MANIFEST_NM_VECTOR) ||
  399.     ((OBJECT_TYPE (*area)) == TC_MANIFEST_CLOSURE) ||
  400.     ((OBJECT_TYPE (*area)) == TC_LINKAGE_SECTION))
  401.     {
  402.       fast long j, count;
  403.  
  404.       count =
  405.     ((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
  406.      ? (READ_CACHE_LINKAGE_COUNT (*area))
  407.      : (OBJECT_DATUM (*area)));
  408.       Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
  409.       area += 1;
  410.       for (j = 0; j < count ; j++, area++)
  411.       {
  412.         printf ("          %08lx    = ", ((unsigned long) (*area)));
  413.     print_long_as_string ((char *) area);
  414.     putchar ('\n');
  415.       }
  416.       i += count;
  417.       area -= 1;
  418.     }
  419.     else
  420.     {
  421.       Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
  422.     }
  423.   }
  424.   return (area);
  425. }
  426.  
  427. void
  428. DEFUN (main, (argc, argv),
  429.        int argc AND
  430.        char **argv)
  431. {
  432.   int counter = 0;
  433.  
  434.   while (1)
  435.   {
  436.     fast SCHEME_OBJECT *Next;
  437.     long total_length, load_length;
  438.  
  439.     if (argc == 1)
  440.     {
  441.       switch (Read_Header ())
  442.       {
  443.     case FASL_FILE_FINE :
  444.       if (counter != 0)
  445.       {
  446.         printf ("\f\n\t*** New object ***\n\n");
  447.       }
  448.           break;
  449.  
  450.       /* There should really be a difference between no header
  451.          and a short header.
  452.        */
  453.  
  454.     case FASL_FILE_TOO_SHORT:
  455.       exit (0);
  456.  
  457.     default:
  458.     {
  459.       fprintf (stderr,
  460.            "%s: Input does not appear to be in correct FASL format.\n",
  461.            argv[0]);
  462.       exit (1);
  463.       /* NOTREACHED */
  464.     }
  465.       }
  466.       print_fasl_information ();
  467.       printf ("Dumped object (relocated) at 0x%lx\n",
  468.           (Relocate (Dumped_Object)));
  469.     }
  470.     else
  471.     {
  472.       Const_Count = 0;
  473.       Primitive_Table_Size = 0;
  474.       sscanf (argv[1], "%lx", ((long) &Heap_Base));
  475.       sscanf (argv[2], "%lx", ((long) &Const_Base));
  476.       sscanf (argv[3], "%ld", ((long) &Heap_Count));
  477.       printf ("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
  478.           Heap_Base, Const_Base, Heap_Count);
  479.     }
  480.  
  481.     load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
  482.     Data = ((SCHEME_OBJECT *) malloc (sizeof (SCHEME_OBJECT) * (load_length + 4)));
  483.     if (Data == NULL)
  484.     {
  485.       fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4));
  486.       exit (1);
  487.     }
  488.     total_length = (Load_Data (load_length, Data));
  489.     end_of_memory = &Data[total_length];
  490.     if (total_length != load_length)
  491.     {
  492.       printf ("The FASL file does not have the right length.\n");
  493.       printf ("Expected %ld objects.  Obtained %ld objects.\n\n",
  494.           ((long) load_length), ((long) total_length));
  495.       if (total_length < Heap_Count)
  496.       {
  497.     Heap_Count = total_length;
  498.       }
  499.       total_length -= Heap_Count;
  500.       if (total_length < Const_Count)
  501.       {
  502.     Const_Count = total_length;
  503.       }
  504.       total_length -= Const_Count;
  505.       if (total_length < Primitive_Table_Size)
  506.       {
  507.     Primitive_Table_Size = total_length;
  508.       }
  509.     }
  510.  
  511.     if (Heap_Count > 0)
  512.     {
  513.       Next = show_area (Data, 0, Heap_Count, "Heap");
  514.     }
  515.     if (Const_Count > 0)
  516.     {
  517.       Next = show_area (Next, Heap_Count, Const_Count, "Constant Space");
  518.     }
  519.     if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
  520.     {
  521.       long arity, size;
  522.       fast long entries, count;
  523.  
  524.       /* This is done in case the file is short. */
  525.       end_of_memory[0] = ((SCHEME_OBJECT) 0);
  526.       end_of_memory[1] = ((SCHEME_OBJECT) 0);
  527.       end_of_memory[2] = ((SCHEME_OBJECT) 0);
  528.       end_of_memory[3] = ((SCHEME_OBJECT) 0);
  529.  
  530.       entries = Primitive_Table_Length;
  531.       printf ("\nPrimitive table: number of entries = %ld\n\n", entries);
  532.  
  533.       for (count = 0;
  534.        ((count < entries) && (Next < end_of_memory));
  535.        count += 1)
  536.       {
  537.     arity = (FIXNUM_TO_LONG (*Next));
  538.     Next += 1;
  539.     size = (OBJECT_DATUM (*Next));
  540.     printf ("Number = %3lx; Arity = %2ld; Name = ", count, arity);
  541.     scheme_string ((Next - Data), true);
  542.     Next += (1 + size);
  543.       }
  544.       printf ("\n");
  545.     }
  546.     if (argc != 1)
  547.     {
  548.       exit (0);
  549.     }
  550.     free ((char *) Data);
  551.     counter = 1;
  552.   }
  553. }
  554.